home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / cmpnew / cmpspecial.c < prev    next >
C/C++ Source or Header  |  1987-06-04  |  11KB  |  460 lines
  1.  
  2. /* (C) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved. */
  3. #include <cmpinclude.h>
  4. #include "cmpspecial.h"
  5. init_cmpspecial(start,size,data)char *start;int size;object data;
  6. {    register object *base=vs_top;register object *sup=base+VM2;vs_check;
  7.     Cstart=start;Csize=size;Cdata=data;set_VV(VV,VM1,data);
  8.     (void)(putprop(VV[0],VV[1],VV[2]));
  9.     (void)(putprop(VV[3],VV[4],VV[2]));
  10.     (void)(putprop(VV[3],VV[5],VV[6]));
  11.     (void)(putprop(VV[7],VV[8],VV[2]));
  12.     (void)(putprop(VV[9],VV[10],VV[2]));
  13.     (void)(putprop(VV[11],VV[12],VV[2]));
  14.     (void)(putprop(VV[13],VV[14],VV[2]));
  15.     (void)(putprop(VV[13],VV[15],VV[6]));
  16.     MF(VV[1],L9,start,size,data);
  17.     MF(VV[10],L10,start,size,data);
  18.     MF(VV[12],L11,start,size,data);
  19.     MF(VV[8],L12,start,size,data);
  20.     MF(VV[14],L13,start,size,data);
  21.     MF(VV[15],L14,start,size,data);
  22.     MF(VV[4],L15,start,size,data);
  23.     MF(VV[5],L16,start,size,data);
  24.     (void)(putprop(VV[38],VV[51],VV[52]));
  25.     (void)(putprop(VV[50],VV[53],VV[52]));
  26.     MF(VV[51],L19,start,size,data);
  27.     MF(VV[53],L20,start,size,data);
  28.     vs_top=vs_base=base;
  29. }
  30. /*    function definition for C1QUOTE    */
  31.  
  32. static L9()
  33. {    register object *base=vs_base;
  34.     register object *sup=base+VM3;
  35.     vs_reserve(VM3);
  36.     check_arg(1);
  37.     vs_top=sup;
  38. TTL:;
  39.     if(!(endp(base[0]))){
  40.     goto T11;}
  41.     base[1]= VV[0];
  42.     base[2]= VV[16];
  43.     base[3]= VV[17];
  44.     (void)simple_symlispcall_no_event(VV[56],base+1,3);
  45. T11:;
  46.     if(endp(cdr(base[0]))){
  47.     goto T17;}
  48.     base[1]= VV[0];
  49.     base[2]= VV[16];
  50.     base[3]= make_fixnum(length(base[0]));
  51.     (void)simple_symlispcall_no_event(VV[57],base+1,3);
  52. T17:;
  53.     base[1]= car(base[0]);
  54.     base[2]= Ct;
  55.     symlispcall_no_event(VV[58],base+1,2);
  56.     return;
  57. }
  58. /*    function definition for C1EVAL-WHEN    */
  59.  
  60. static L10()
  61. {    register object *base=vs_base;
  62.     register object *sup=base+VM4;
  63.     vs_reserve(VM4);
  64.     check_arg(1);
  65.     vs_top=sup;
  66. TTL:;
  67.     if(!(endp(base[0]))){
  68.     goto T25;}
  69.     base[1]= VV[9];
  70.     base[2]= VV[16];
  71.     base[3]= VV[17];
  72.     (void)simple_symlispcall_no_event(VV[56],base+1,3);
  73. T25:;
  74.     {object V1;
  75.     object V2;
  76.     V1= car(base[0]);
  77.     V2= car((V1));
  78. T34:;
  79.     if(!(endp((V1)))){
  80.     goto T35;}
  81.     symlispcall_no_event(VV[59],base+1,0);
  82.     return;
  83. T35:;
  84.     {object V3= (V2);
  85.     if((V3!= VV[60]))goto T40;
  86.     base[1]= cdr(base[0]);
  87.     symlispcall_no_event(VV[61],base+1,1);
  88.     return;
  89. T40:;
  90.     if((V3!= VV[62])
  91.     && (V3!= VV[63]))goto T42;
  92.     goto T39;
  93. T42:;
  94.     base[1]= VV[18];
  95.     base[2]= (V2);
  96.     (void)simple_symlispcall_no_event(VV[64],base+1,2);}
  97. T39:;
  98.     V1= cdr((V1));
  99.     V2= car((V1));
  100.     goto T34;}
  101. }
  102. /*    function definition for C1DECLARE    */
  103.  
  104. static L11()
  105. {    register object *base=vs_base;
  106.     register object *sup=base+VM5;
  107.     vs_reserve(VM5);
  108.     check_arg(1);
  109.     vs_top=sup;
  110. TTL:;
  111.     base[1]= VV[19];
  112.     base[2]= make_cons(VV[11],base[0]);
  113.     symlispcall_no_event(VV[64],base+1,2);
  114.     return;
  115. }
  116. /*    function definition for C1THE    */
  117.  
  118. static L12()
  119. {    register object *base=vs_base;
  120.     register object *sup=base+VM6;
  121.     vs_reserve(VM6);
  122.     check_arg(1);
  123.     vs_top=sup;
  124. TTL:;
  125.     base[1]= Cnil;
  126.     base[2]= Cnil;
  127.     base[3]= Cnil;
  128.     if(endp(base[0])){
  129.     goto T53;}
  130.     if(!(endp(cdr(base[0])))){
  131.     goto T52;}
  132. T53:;
  133.     base[4]= VV[7];
  134.     base[5]= VV[20];
  135.     base[6]= make_fixnum(length(base[0]));
  136.     (void)simple_symlispcall_no_event(VV[56],base+4,3);
  137. T52:;
  138.     if(endp(cddr(base[0]))){
  139.     goto T60;}
  140.     base[4]= VV[7];
  141.     base[5]= VV[20];
  142.     base[6]= make_fixnum(length(base[0]));
  143.     (void)simple_symlispcall_no_event(VV[57],base+4,3);
  144. T60:;
  145.     base[4]= cadr(base[0]);
  146.     base[2]= simple_symlispcall_no_event(VV[65],base+4,1);
  147.     base[4]= cadr(base[2]);
  148.     base[1]= simple_symlispcall_no_event(VV[66],base+4,1);
  149.     base[4]=symbol_function(VV[67]);
  150.     base[6]= car(base[0]);
  151.     base[5]= simple_symlispcall_no_event(VV[68],base+6,1);
  152.     base[6]= structure_ref(base[1],VV[21],2);
  153.     base[3]= simple_lispcall_no_event(base+4,2);
  154.     if((base[3])!=Cnil){
  155.     goto T77;}
  156.     base[4]= VV[22];
  157.     base[5]= make_cons(VV[7],base[0]);
  158.     (void)simple_symlispcall_no_event(VV[69],base+4,2);
  159. T77:;
  160.     structure_set(base[1],VV[21],2,base[3]);
  161.     base[4]= listA(3,car(base[2]),base[1],cddr(base[2]));
  162.     vs_top=(vs_base=base+4)+1;
  163.     return;
  164. }
  165. /*    function definition for C1COMPILER-LET    */
  166.  
  167. static L13()
  168. {    register object *base=vs_base;
  169.     register object *sup=base+VM7;
  170.     vs_reserve(VM7);
  171.     check_arg(1);
  172.     vs_top=sup;
  173. TTL:;
  174.     base[1]= Cnil;
  175.     base[2]= Cnil;
  176.     if(!(endp(base[0]))){
  177.     goto T83;}
  178.     base[3]= VV[13];
  179.     base[4]= VV[16];
  180.     base[5]= VV[17];
  181.     (void)simple_symlispcall_no_event(VV[56],base+3,3);
  182. T83:;
  183.     {object V4;
  184.     object V5;
  185.     V4= car(base[0]);
  186.     V5= car((V4));
  187. T93:;
  188.     if(!(endp((V4)))){
  189.     goto T94;}
  190.     goto T89;
  191. T94:;
  192.     if(!(type_of((V5))==t_cons)){
  193.     goto T100;}
  194.     if(!(type_of(car((V5)))==t_symbol)){
  195.     goto T103;}
  196.     if(endp(cdr((V5)))){
  197.     goto T102;}
  198.     if(endp(cddr((V5)))){
  199.     goto T102;}
  200. T103:;
  201.     base[3]= VV[23];
  202.     base[4]= (V5);
  203.     (void)simple_symlispcall_no_event(VV[64],base+3,2);
  204. T102:;
  205.     base[1]= make_cons(car((V5)),base[1]);
  206.     if(!(endp(cdr((V5))))){
  207.     goto T116;}
  208.     base[3]= Cnil;
  209.     goto T114;
  210. T116:;
  211.     base[4]= cadr((V5));
  212.     vs_top=(vs_base=base+4)+1;
  213.     Leval();
  214.     vs_top=sup;
  215.     base[3]= vs_base[0];
  216. T114:;
  217.     base[2]= make_cons(base[3],base[2]);
  218.     goto T98;
  219. T100:;
  220.     if(!(type_of((V5))==t_symbol)){
  221.     goto T120;}
  222.     base[1]= make_cons((V5),base[1]);
  223.     base[2]= make_cons(Cnil,base[2]);
  224.     goto T98;
  225. T120:;
  226.     base[3]= VV[24];
  227.     base[4]= (V5);
  228.     (void)simple_symlispcall_no_event(VV[64],base+3,2);
  229. T98:;
  230.     V4= cdr((V4));
  231.     V5= car((V4));
  232.     goto T93;}
  233. T89:;
  234.     base[1]= reverse(base[1]);
  235.     base[2]= reverse(base[2]);
  236.     {object symbols,values;
  237.     bds_ptr V6=bds_top;
  238.     base[3]= base[1];
  239.     symbols= base[3];
  240.     base[4]= base[2];
  241.     values= base[4];
  242.     while(!endp(symbols)){
  243.     if(type_of(MMcar(symbols))!=t_symbol)
  244.     FEinvalid_variable("~s is not a symbol.",MMcar(symbols));
  245.     if(endp(values))bds_bind(MMcar(symbols),OBJNULL);
  246.     else{bds_bind(MMcar(symbols),MMcar(values));
  247.     values=MMcdr(values);}
  248.     symbols=MMcdr(symbols);}
  249.     base[3]= cdr(base[0]);
  250.     base[4]= simple_symlispcall_no_event(VV[61],base+3,1);
  251.     bds_unwind(V6);
  252.     base[0]= base[4];}
  253.     base[3]= list(5,VV[13],cadr(base[0]),base[1],base[2],base[0]);
  254.     vs_top=(vs_base=base+3)+1;
  255.     return;
  256. }
  257. /*    function definition for C2COMPILER-LET    */
  258.  
  259. static L14()
  260. {    register object *base=vs_base;
  261.     register object *sup=base+VM8;
  262.     vs_reserve(VM8);
  263.     check_arg(3);
  264.     vs_top=sup;
  265. TTL:;
  266.     {object symbols,values;
  267.     bds_ptr V7=bds_top;
  268.     base[3]= base[0];
  269.     symbols= base[3];
  270.     base[4]= base[1];
  271.     values= base[4];
  272.     while(!endp(symbols)){
  273.     if(type_of(MMcar(symbols))!=t_symbol)
  274.     FEinvalid_variable("~s is not a symbol.",MMcar(symbols));
  275.     if(endp(values))bds_bind(MMcar(symbols),OBJNULL);
  276.     else{bds_bind(MMcar(symbols),MMcar(values));
  277.     values=MMcdr(values);}
  278.     symbols=MMcdr(symbols);}
  279.     base[3]= base[2];
  280.     symlispcall_no_event(VV[70],base+3,1);
  281.     bds_unwind(V7);
  282.     return;}
  283. }
  284. /*    function definition for C1FUNCTION    */
  285.  
  286. static L15()
  287. {    register object *base=vs_base;
  288.     register object *sup=base+VM9;
  289.     vs_reserve(VM9);
  290.     bds_check;
  291.     check_arg(1);
  292.     vs_top=sup;
  293. TTL:;
  294.     base[1]= Cnil;
  295.     if(!(endp(base[0]))){
  296.     goto T144;}
  297.     base[2]= VV[3];
  298.     base[3]= VV[16];
  299.     base[4]= VV[17];
  300.     (void)simple_symlispcall_no_event(VV[56],base+2,3);
  301. T144:;
  302.     if(endp(cdr(base[0]))){
  303.     goto T150;}
  304.     base[2]= VV[3];
  305.     base[3]= VV[16];
  306.     base[4]= make_fixnum(length(base[0]));
  307.     (void)simple_symlispcall_no_event(VV[57],base+2,3);
  308. T150:;
  309.     base[2]= car(base[0]);
  310.     if(!(type_of(base[2])==t_symbol)){
  311.     goto T158;}
  312.     base[3]= base[2];
  313.     base[1]= simple_symlispcall_no_event(VV[71],base+3,1);
  314.     if((base[1])==Cnil){
  315.     goto T161;}
  316.     if(!(car(base[1])==VV[25])){
  317.     goto T161;}
  318.     base[3]= list(3,VV[3],symbol_value(VV[26]),base[1]);
  319.     vs_top=(vs_base=base+3)+1;
  320.     return;
  321. T161:;
  322.     base[4]= VV[27];
  323.     base[6]= get(base[2],VV[28],Cnil);
  324.     base[5]= (base[6]==Cnil?Ct:Cnil);
  325.     base[3]= simple_symlispcall_no_event(VV[72],base+4,2);
  326.     base[4]= list(3,VV[29],base[3],base[2]);
  327.     base[5]= list(3,VV[3],base[3],base[4]);
  328.     vs_top=(vs_base=base+5)+1;
  329.     return;
  330. T158:;
  331.     if(!(type_of(base[2])==t_cons)){
  332.     goto T172;}
  333.     if(!(car(base[2])==VV[30])){
  334.     goto T172;}
  335.     if(!(endp(cdr(base[2])))){
  336.     goto T176;}
  337.     base[3]= VV[31];
  338.     base[4]= base[2];
  339.     (void)simple_symlispcall_no_event(VV[64],base+3,2);
  340. T176:;
  341.     base[3]= make_cons(VV[33],symbol_value(VV[32]));
  342.     base[4]= make_cons(VV[33],symbol_value(VV[34]));
  343.     base[5]= make_cons(VV[33],symbol_value(VV[35]));
  344.     base[6]= make_cons(VV[33],symbol_value(VV[36]));
  345.     bds_bind(VV[32],base[3]);
  346.     bds_bind(VV[34],base[4]);
  347.     bds_bind(VV[35],base[5]);
  348.     bds_bind(VV[36],base[6]);
  349.     base[7]= cdr(base[2]);
  350.     base[2]= simple_symlispcall_no_event(VV[73],base+7,1);
  351.     base[7]= list(3,VV[3],cadr(base[2]),base[2]);
  352.     vs_top=(vs_base=base+7)+1;
  353.     bds_unwind1;
  354.     bds_unwind1;
  355.     bds_unwind1;
  356.     bds_unwind1;
  357.     return;
  358. T172:;
  359.     base[3]= VV[37];
  360.     base[4]= base[2];
  361.     symlispcall_no_event(VV[64],base+3,2);
  362.     return;
  363. }
  364. /*    function definition for C2FUNCTION    */
  365.  
  366. static L16()
  367. {    register object *base=vs_base;
  368.     register object *sup=base+VM10;
  369.     vs_reserve(VM10);
  370.     check_arg(1);
  371.     vs_top=sup;
  372. TTL:;
  373.     {object V8= car(base[0]);
  374.     if((V8!= VV[29]))goto T190;
  375.     base[3]= caddr(base[0]);
  376.     base[2]= simple_symlispcall_no_event(VV[74],base+3,1);
  377.     base[1]= list(2,VV[38],base[2]);
  378.     symlispcall_no_event(VV[75],base+1,1);
  379.     return;
  380. T190:;
  381.     if((V8!= VV[25]))goto T194;
  382.     if((cadddr(base[0]))==Cnil){
  383.     goto T196;}
  384.     base[1]= list(2,VV[39],structure_ref(caddr(base[0]),VV[40],2));
  385.     symlispcall_no_event(VV[75],base+1,1);
  386.     return;
  387. T196:;
  388.     base[1]= list(2,VV[41],structure_ref(caddr(base[0]),VV[40],1));
  389.     symlispcall_no_event(VV[75],base+1,1);
  390.     return;
  391. T194:;
  392.     base[2]=symbol_function(VV[76]);
  393.     base[3]= VV[42];
  394.     base[4]= VV[43];
  395.     base[5]= VV[44];
  396.     setq(VV[45],number_plus(symbol_value(VV[45]),VV[16]));
  397.     base[6]= symbol_value(VV[45]);
  398.     base[1]= simple_lispcall_no_event(base+2,4);
  399.     if((symbol_value(VV[47]))!=Cnil){
  400.     goto T210;}
  401.     base[2]= Cnil;
  402.     goto T208;
  403. T210:;
  404.     base[2]= make_cons(VV[17],VV[17]);
  405. T208:;
  406.     base[3]= list(5,VV[43],base[2],symbol_value(VV[48]),base[1],base[0]);
  407.     setq(VV[46],make_cons(base[3],symbol_value(VV[46])));
  408.     setq(VV[49],make_cons(base[1],symbol_value(VV[49])));
  409.     base[2]= list(3,VV[50],structure_ref(base[1],VV[40],3),symbol_value(VV[47]));
  410.     symlispcall_no_event(VV[75],base+2,1);
  411.     return;}
  412. }
  413. /*    function definition for WT-SYMBOL-FUNCTION    */
  414.  
  415. static L19()
  416. {    register object *base=vs_base;
  417.     register object *sup=base+VM11;
  418.     vs_reserve(VM11);
  419.     check_arg(1);
  420.     vs_top=sup;
  421. TTL:;
  422.     if((symbol_value(VV[54]))==Cnil){
  423.     goto T216;}
  424.     princ_str("symbol_function(VV[",VV[55]);
  425.     base[1]= base[0];
  426.     (void)simple_symlispcall_no_event(VV[77],base+1,1);
  427.     princ_str("])",VV[55]);
  428.     base[1]= Cnil;
  429.     vs_top=(vs_base=base+1)+1;
  430.     return;
  431. T216:;
  432.     princ_str("(VV[",VV[55]);
  433.     base[1]= base[0];
  434.     (void)simple_symlispcall_no_event(VV[77],base+1,1);
  435.     princ_str("]->s.s_gfdef)",VV[55]);
  436.     base[1]= Cnil;
  437.     vs_top=(vs_base=base+1)+1;
  438.     return;
  439. }
  440. /*    function definition for WT-MAKE-CCLOSURE    */
  441.  
  442. static L20()
  443. {    register object *base=vs_base;
  444.     register object *sup=base+VM12;
  445.     vs_reserve(VM12);
  446.     check_arg(2);
  447.     vs_top=sup;
  448. TTL:;
  449.     princ_str("\n    make_cclosure(LC",VV[55]);
  450.     base[2]= base[0];
  451.     (void)simple_symlispcall_no_event(VV[77],base+2,1);
  452.     princ_str(",Cnil,",VV[55]);
  453.     base[2]= base[1];
  454.     (void)simple_symlispcall_no_event(VV[78],base+2,1);
  455.     princ_str(",Cdata,Cstart,Csize)",VV[55]);
  456.     base[2]= Cnil;
  457.     vs_top=(vs_base=base+2)+1;
  458.     return;
  459. }
  460.